COMMENT ⊗   VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	begin "MFPRE" comment The METAFONT preprocessor.
C00004 00003	Material copied from MFSYS
C00022 00004	Initializing the memory
C00029 00005	The driver routine
C00030 ENDMK
C⊗;
begin "MFPRE" comment The METAFONT preprocessor.

comment This program builds the tables that define METAFONT's initial
memory state, including its built-in reserved words.
The relevant sections of MFNTRP explain the format of these tables.

MFPRE has been written as a separate module since it is unnecessary to have
all this lengthy initialization code present when running METAFONT, and since the
SAIL system has no mechanism for overlaying unneeded program segments.

The next page of code is simply copied from MFSYS, then comes
new stuff and a new driver program instead of the MFSYS main program;

require "MFHDR.SAI" source_file;
require "MFNTRP.REL" load_module;
require "MFRAST.REL" load_module;
require "MFOUT.REL" load_module;
comment Material copied from MFSYS;

comment Error handling procedures: quit,error,backerror,overflow,confusion;

label end_of_MF,final_end;
internal procedure quit # closes output files and terminates METAFONT;
begin integer c;
DEBUGONLY print(nextline,"Quitting. Do you want a chance to see the memory?");
DEBUGONLY c←inchrw;
DEBUGONLY if c="y" then bail;
go to end_of_MF;
end;

internal boolean pausing_on_errors # should METAFONT wait after error messages?;
internal boolean deletions_allowed # is it safe for error routine to call getnext?;

internal procedure error(string s) # prints an error message;
begin comment The string s explains the type of error. This is displayed to the
user and then the current source code position is indicated;
print(nextline,"! ",s,".");
dumpcontext # prints indication of where the scanner is now;
if pausing_on_errors then
  loop	begin integer c;
	print("↑") # prompt the user;
	clrbuf # if user was typing ahead, clear the system buffer;
	c←inchrw # wait for user to type a character;
	setprint(null,"F"); print(c&null); setprint(null,"B") # echo on ERRORS.TMP;
	if c='15 then begin c←inchrw # ignore the line-feed; return end;
	if c='12 then begin pausing_on_errors←false; return end;
	if c>'140 then c←c-'40 # change lower case to upper case;
	IFWAITS if c="E" or c="T" then
		begin comment abort and enter the system editor;
		if curfile then
			begin setprint(null,"N") # close the errors file;
			edfile(curfile,curfline,curfpage);
			end
		else	begin print(" (sorry, there's no current file)"); quit;
			end;
		end; ENDWAITS
	if c="I" then
		begin pushinput;
		print(nextline,"*"); inbuf←inchwl # wait for user to type a line;
		setprint(null,"F"); print(inbuf&'15); setprint(null,"B") # echo it;
		curbuf←inbuf; filename←null;
		return;
		end;
	if c="X" then go to end_of_MF;
	if c≥"1" and c≤"9" and deletions_allowed then
		begin integer i; i←c-"0";
		while i>0 do
			begin getnext # recursive call shouldn't happen;
			i←i-1;
			end;
		dumpcontext # print new scanner status;
		continue;
		end;
	DEBUGONLY if c="B" then
	DEBUGONLY	begin bail;
	DEBUGONLY	return;
	DEBUGONLY	end;
	print(nextline,"Type <cr> to continue, <lf> to flash error messages,");
	if deletions_allowed then print(nextline,
		"	1 or ... or 9 to ignore the next 1 to 9 tokens of input,");
	print(nextline,"	i or I to insert something,",
	IFWAITS " e or E to edit,", ENDWAITS
	" x or X to quit.",nextline);
	end;
end;

internal procedure errorstop(string s) # prints message and dies;
begin pausing_on_errors←false;
error(s);
quit;
end;

internal procedure reportoverflow(string s; integer n)
	# for fatal errors when a METAFONT table is undersized;
errorstop("METAFONT capacity exceeded, sorry ["&s&"="&cvs(n)&"]");

internaldef overflow(s)=⊂reportoverflow("s",s)⊃ # specifies inadequate table size;
internal procedure memoverflow; overflow(memsize);
internal procedure vmemoverflow; overflow(vmemsize);

internal procedure confusion # METAFONT consistency check failure;
errorstop("This can't happen");

comment Dynamic memory allocation: links,memsize,vmemsize,mem,vmem,memreal,vmemint;

comment METAFONT does nearly all of its own memory allocation, so that it can
readily be transported into environments that do not have automatic
facilities for strings, garbage collection, etc. The dynamic storage
requirements of METAFONT are handled by providing a large integer array "mem" 
and a smaller real array "vmem". Pointer variables are indices into these arrays.
When a pointer value p is less than vmemsize, it essentially is pointing to a
two-word node (mem[p], vmem[p]). When p is ≥ vmemsize, it essentially points to
the one-word node mem[p].

Separate available-space lists are maintained for two-word nodes and one-word
nodes. In an emergency, a two-word node will be temporarily assigned to one-word
duty.
;
internaldef links = 13 # number of bits per pointer;
internaldef memsize=5000 # size of dynamic list memory, must be ≤ 2↑links;
internaldef vmemsize=2500 # size of two-word list memory, must be << memsize;
comment MFHDR contains the true values of these volatile parameters;

comment saf integer array mem[0:memsize-1] # dynamic list memory;
comment saf real array vmem[0:vmemsize-1] # two-word list memory;
comment mem and vmem have been made internal to MFNTRP, for the sake of more
efficient code;

internaldef memreal(p)=⊂memory[location(mem[p]),real]⊃ # mem[p] as type real;
internaldef vmemint(p)=⊂memory[location(vmem[p]),integer]⊃ # vmem[p] as integer;

SHOWMEM internal integer oneused,twoused # how much memory is in use;

comment Partial field macros: field,ufield,link,info,setfield...setinfo;

comment The following macros are for accessing and modifying partial fields
of packed words. If f is a field name, then fs denotes its size in bits
and fd denotes its displacement from the right of the word. These sizes and
displacements are defined at compile time--e.g.,"links" for size of link fields.
In the following definitions, x denotes the word being modified and y denotes
a new value to be inserted into the specified field (it must not be too
large for the field). The definitions look inefficient, but they take
advantage of the fact that SAIL does a lot of local optimization;


internaldef fs(f) = ⊂f⊃&"s" # field size of f, in bits;
internaldef fd(f) = ⊂f⊃&"d" # field displacement of f, in bits;

internaldef field(f,x) = ⊂ifc fd(f)=0 thenc ((x) land (2↑fs(f)-1))
	elsec ifc fs(f)+fd(f)≥bitsperwd thenc ((x) lsh -fd(f))
	elsec (((x) lsh -fd(f)) land (2↑fs(f)-1)) endc endc⊃ # field f of x;

internaldef setfield(f,x,y) = ⊂ifc fd(f)=0 thenc x←(x land(-2↑fs(f)))+(y)
	elsec ifc fs(f)+fd(f)≥bitsperwd thenc 
		x←((x lsh(bitsperwd-fd(f)))+(y))rot fd(f)
	elsec x←(((x rot -fd(f))land(-2↑fs(f)))+(y))rot fd(f) endc endc⊃
		# sets field f of x equal to y, 0 ≤ y < 2↑fs(f);

comment Sometimes an unshifted field is desired. For this purpose, we use
ufield instead of field, and deal with values times 2↑fd;

internaldef ufield(f,x) = ⊂((x) land((1 lsh(fs(f)+fd(f)))-2↑fd(f)))⊃
		# unshifted field f of x;
internaldef setufield(f,x,y) = ⊂x←(x land lnot((1 lsh(fs(f)+fd(f)))-2↑fd(f)))+(y)⊃
		# field f of x set to unshifted value y;

comment The special case of a pointer field at the right of a word is
most common, so there are special conventions for it. When p is a pointer,
we write link(p) for the pointer field of mem[p] and info(p) for the
(shifted) remaining fields of the word;

internaldef linkd = 0 # displacement of link field;
internaldef link(p) = ⊂field(link,mem[p])⊃ # link field of mem[p];
internaldef setlink(p,y) = ⊂setfield(link,mem[p],y)⊃ # sets link(p)←y;
internaldef infod = links, infos = bitsperwd-infod # definition of info field;
internaldef info(p) = ⊂field(info,mem[p])⊃ # info field of mem[p];
internaldef setinfo(p,y) = ⊂setfield(info,mem[p],y)⊃ # sets info(p)←y;

DEBUGONLY integer procedure lk(integer x);
DEBUGONLY return(x land(2↑links-1)) # link field of packed word;
DEBUGONLY integer procedure fo(integer x);
DEBUGONLY return(x lsh -infod) # info field of packed word;

comment Memory allocation: getavail, getvavail, freeavail, dslist;

comment	The dynamic memory is accessed via three simple macros:
	getavail(p) makes p point to a new one-word node,
	gettavail(p) makes p point to a new two-word node,
	freeavail(p) returns node p to storage.
;
internal integer avail # head of available space list for one-word nodes;
internal integer vavail # head of available space list for two-word nodes;
internaldef getavail(p) = ⊂begin if(p←avail)then
	begin avail←mem[avail]: SHOWMEM oneused←oneused+1: end
	else if(p←vavail)then
	begin vavail←mem[vavail]: SHOWMEM twoused←twoused+1: end
	else memoverflow: end⊃ # p ← new one-word node;
internaldef getvavail(p) = ⊂begin if(p←vavail)then vavail←mem[vavail]
	else vmemoverflow: SHOWMEM twoused←twoused+1: end⊃ # p ← new two-wd node;
internaldef freeavail(p) = ⊂if p<vmemsize then
	begin mem[p]←vavail: vavail←p: SHOWMEM twoused←twoused-1: end
	else begin mem[p]←avail: avail←p: SHOWMEM oneused←oneused-1: end⊃
		# node p now available;

comment The following procedure can be used to free up an entire linked list;
internal procedure dslist(integer p) # makes list of nodes available;
begin integer q # pointer to node following node p;
while p do
	begin q←link(p); freeavail(p); p←q;
	end;
end;

comment Memory, continued: checkmem, searchmem;

comment There are also two procedures that may come in handy when diagnosing
mysterious errors;

DEBUGONLY integer array free[0:memsize-1];
DEBUGONLY internal procedure checkmem(boolean printlocs) # checks links in mem;
DEBUGONLY begin comment This procedure checks the format of the available space
DEBUGONLY lists and (if printlocs is true) prints those locations of mem that were
DEBUGONLY free the last time this procedure was called but reserved now.
DEBUGONLY All nodes should be returned to the avail lists when METAFONT is done with
DEBUGONLY them, and checkmem can be used to check if this has been done correctly;
DEBUGONLY integer p,i;
DEBUGONLY p←avail;
DEBUGONLY while p do
DEBUGONLY 	begin if (mem[p]≥memsize) or (free[p] land 1) or
DEBUGONLY		(mem[p]≠0 and mem[p]<vmemsize) then
DEBUGONLY 		begin print(nextline,"avail list clobbered at ",p);
DEBUGONLY		bail;
DEBUGONLY		done;
DEBUGONLY 		end;
DEBUGONLY 	free[p]←free[p] lor 1;
DEBUGONLY 	p←mem[p];
DEBUGONLY 	end;
DEBUGONLY p←vavail;
DEBUGONLY while p do
DEBUGONLY 	begin if (mem[p]≥vmemsize) or (free[p] land 1) or (mem[p]<0) then
DEBUGONLY 		begin print(nextline,"vavail list clobbered at ",p);
DEBUGONLY		bail;
DEBUGONLY		done;
DEBUGONLY 		end;
DEBUGONLY 	free[p]←free[p] lor 1;
DEBUGONLY 	p←mem[p];
DEBUGONLY 	end;
DEBUGONLY if printlocs then print(nextline,"New busy locs: ");
DEBUGONLY for i←0 thru memsize-1 do
DEBUGONLY 	begin if free[i] land 3 = 2 and printlocs then print(i," ");
DEBUGONLY 	free[i]←free[i] lsh 1;
DEBUGONLY 	end;
DEBUGONLY end;

DEBUGONLY procedure searchmem(integer p) # finds pointers to p;
DEBUGONLY begin integer i;
DEBUGONLY for i←0 thru memsize-1 do
DEBUGONLY 	begin if link(i)=p then print(nextline,"link(",i,")");
DEBUGONLY 	if name(i)=p then print(nextline,"name(",i,")");
DEBUGONLY	if field(link,vmemint(i))=p then print(nextline,"vlink(",i,")");
DEBUGONLY	if field(info,vmemint(i))=p then print(nextline,"vinfo(",i,")");
DEBUGONLY 	end;
DEBUGONLY for i←0 thru hashsize-1 do if hashh[i]=p then
DEBUGONLY	print(nextline,"link in hash[",i,"]");
DEBUGONLY end;

comment A few words of the memory are dedicated to fixed usage. Location mem[0]
is used during elementary list manipulations, and location wvar (the one-word
node) is the list head for w-variables;
internaldef wvar = memsize-1 # head of list for w-variables;
internaldef depvar = wvar-1 # head of list for dependent variables;
internaldef temphead = depvar-1 # temporary list head for created lists;
internaldef main = ⊂1⊃ # area header for main program;
internaldef firstvmem = 2, lastmem = temphead-1 # nodes not specially dedicated;
comment Initializing the memory;

procedure identer(string t; integer typ,val);
begin comment This procedure forms the packed name corresponding to string t
and enters this identifier in the has table, giving it the specified type
and value;
integer c,s,l,firstfew;
firstfew←(lop(t) land '37) lsh (bitsperwd-bitsrem-5); l←1;
s←bitsperwd-bitsrem-5;
while (c←lop(t)) do
	begin l←l+1; s←s-5;
	if s≥0 then firstfew ← firstfew+((c land '37) lsh s);
	end;
c←idlookup(firstfew,l);
mem[c]←mem[c]+((typ-newid)lsh typed); vmemint(c)←val;
end;

procedure initmem # initializes the dynamic memory;
begin integer i;
mem[main]←areahead lsh typed; vmemint(main)←(main lsh infod)+main # no xy-variables;
mem[wvar]←(areahead lsh typed) + wvar # no w-variables;
for i←firstvmem thru vmemsize-2 do mem[i+1]←i; mem[firstvmem]←0; vavail←vmemsize-1;
for i←vmemsize thru lastmem-1 do mem[i+1]←i; mem[vmemsize]←0; avail←lastmem;

identer("input",innput,0);
identer("var",varparam,0);
identer("index",indexparam,0);
identer("end",stop,0);
identer("if",iff,0);
identer("else",elsse,0);
identer("fi",ffi,0);
identer("lft",direction,lft);
identer("rt",direction,rt);
identer("top",direction,top);
identer("bot",direction,bot);
identer("nrand",randm,0);
identer("sqrt",unary,root);
identer("sind",unary,sine);
identer("cosd",unary,cosine);
identer("round",unary,round);
identer("good",unary,good);
identer("cpen",penname,cpen);
identer("hpen",penname,hpen);
identer("vpen",penname,vpen);
identer("lpen",penname,lpen);
identer("rpen",penname,rpen);
identer("spen",penname,spen);
identer("epen",penname,epen);
identer("call",cawl,0);
identer("new",new,0);
identer("trxx",mfparam,1);
identer("trxy",mfparam,2);
identer("incx",mfparam,3);
identer("tryx",mfparam,4);
identer("tryy",mfparam,5);
identer("incy",mfparam,6);
identer("charwd",mfparam,7);
identer("charht",mfparam,8);
identer("chardp",mfparam,9);
identer("charic",mfparam,10);
identer("safetyfactor",mfparam,11);
identer("maxvr",mfparam,12);
identer("minvr",mfparam,13);
identer("maxvs",mfparam,14);
identer("minvs",mfparam,15);
identer("epenxfactor",mfparam,16);
identer("epenyfactor",mfparam,17);
identer("epenxcorr",mfparam,18);
identer("epenycorr",mfparam,19);
identer("designsize",mfparam,20);
identer("hresolution",mfparam,21) # xresolution looks like an x-var;
identer("vresolution",mfparam,22) # yresolution looks like a y-var;
identer("magnification",mfparam,23);
identer("charwx",mfparam,24);
identer("charwy",mfparam,25);
identer("rotation",mfparam,26);
identer("hpenht",mfparam,intpar+1);
identer("vpenwd",mfparam,intpar+2);
identer("lpenht",mfparam,intpar+3);
identer("rpenht",mfparam,intpar+4);
identer("dumplength",mfparam,intpar+5);
identer("charcode",mfparam,intpar+6);
identer("chardw",mfparam,intpar+7);
identer("nseed",mfparam,intpar+8);
identer("dumpwindow",mfparam,intpar+9);
identer("maxht",mfparam,intpar+10);
identer("fontfacebyte",mfparam,intpar+11);
identer("fontidentifier",mfparam,stringpar+1);
identer("codingscheme",mfparam,stringpar+2);
identer("crsbreak",break,10);
identer("eqtrace",contrl,'1);
identer("titletrace",contrl,'2);
identer("calltrace",contrl,'4);
identer("pause",contrl,'10);
identer("pagewarning",contrl,'20);
identer("penreset",contrl,'40);
identer("drawtrace",contrl,'100);
identer("modtrace",contrl,'200);
identer("plottrace",contrl,'400);
identer("proofmode",contrl,'1000);
identer("chrmode",contrl,'2000);
identer("tfmmode",contrl,'4000);
identer("fntmode",contrl,'10000);
identer("crsmode",contrl,'20000);
identer("points",contrl,'400000);
identer("chardisplay",contrl,'1000000);
identer("drawdisplay",contrl,'2000000);
IFPRESS identer("arrow",contrl,'4000000); ENDPRESS
IFPRESS identer("color",contrl,'10000000); ENDPRESS
IFDOVERMODES identer("ocmode",contrl,'20000000); ENDDOVERMODES
IFDOVERMODES identer("dotwdmode",contrl,'40000000); ENDDOVERMODES
IFDOVERMODES identer("vectorwidths",contrl,'100000000); ENDDOVERMODES
identer("no",no,0);
identer("draw",draw,0);
identer("ddraw",ddraw,0);
identer("subroutine",subrtn,0);
identer("varchar",varchar,0);
identer("charlist",charlist,0);
identer("texinfo",texinfo,0);
identer("lig",lig,0);
identer("invisible",invisible,0);
identer("kern",kern,0);
identer("binput",binput,0);
end;
comment The driver routine;

comment The declarations have now ended, MFPRE starts here after being loaded;

integer chan;
hptr←0;
forcednew←false;
initmem;
open(chan←getchan,"DSK",'10,0,2,0,0,eof);
enter(chan,"MFINI.TBL", eof);
wordout(chan,hashsize);
wordout(chan,vmemsize);
wordout(chan,memsize);
wordout(chan,hptr);
arryout(chan,hashh[0],hashsize);
arryout(chan,hname[0],hptr);
arryout(chan,mem[0],memsize);
arryout(chan,vmem[0],vmemsize);
wordout(chan,avail);
wordout(chan,vavail);
release(chan);

print(nextline,"METAFONT's tables written on MFINI.TBL.");
end_of_MF:
final_end: end "MFPRE"